io Programmo 70/IOPROG_70.ISO/soft/Codice/Libro Allegato/EsempiLibroVBA.bas

BASIC Source File | 2003-05-02 | 6.4 KB | 228 lines

Attribute VB_Name = "EsempiLibroVBA"
Option Explicit


Sub sommaByRef(ByRef a)
 a = a + 1
End Sub

Sub sommaByVal(ByVal a)
 a = a + 1
End Sub

Sub sommaDefault(a)
 a = a + 1
End Sub

Function funSommaDefault(paramA)
    paramA = paramA + 1
    funSommaDefault = paramA
End Function


Sub test()
    Dim a As Integer
    a = 1
    MsgBox "Valore iniziale: " & a
    sommaDefault a
    MsgBox "Dopo 'sommaDefault a' : " & a
    sommaDefault (a)
    MsgBox "Dopo 'sommaDefault (a)' : " & a
    Call sommaDefault(a)
    MsgBox "Dopo 'Call sommaDefault(a)' : " & a
    a = 1
    MsgBox "Valore iniziale: " & a
    sommaByRef a
    MsgBox "Dopo 'sommaByRef a' : " & a
    sommaByRef (a)
    MsgBox "Dopo 'sommaByRef (a) :' " & a
    Call sommaByRef(a)
    MsgBox "Dopo 'Call sommaByRef(a) :' " & a
    a = 1
    MsgBox "Valore iniziale: " & a
    sommaByVal a
    MsgBox "Dopo 'sommaByVal a' : " & a
    sommaByVal (a)
    MsgBox "Dopo 'sommaByVal (a)' : " & a
    Call sommaByVal(a)
    MsgBox "Dopo 'Call Call sommaByVal(a)' : " & a
End Sub


Sub testFun()
    Dim a As Integer
    a = 1
    MsgBox "Valore iniziale: " & a
    MsgBox "'funSommaDefault(a)' ritorna : " & funSommaDefault(a)
    MsgBox "Ora 'a' vale : " & a
    funSommaDefault a
    MsgBox "applicato 'funSommaDefault a'; ora 'a' vale : " & a
End Sub


Sub testmsg()
Dim variab
variab = MsgBox("Testo", vbExclamation + vbYesNo)
End Sub


Sub dimmiComposizione()
    MsgBox "Application.ActiveWorkbook.Name = " & _
        Application.ActiveWorkbook.Name
    MsgBox "Application.Worksheets.Count = " & _
        Application.Worksheets.Count
    MsgBox "Application.Worksheets.Item(1).Name = " & _
        Application.Worksheets.Item(1).Name
    MsgBox "Application.Worksheets.Item(""Foglio1"").Name = " & _
        Application.Worksheets.Item("Foglio1").Name
    Dim elem As Worksheet

    For Each elem In Application.Worksheets
        MsgBox "(insieme Worksheets) elem.Name = " & elem.Name
    Next
    MsgBox "Application.Charts.Count = " & Application.Charts.Count
    For Each elem In Application.Charts
        MsgBox "(insieme Charts) elem.Name = " & elem.Name
    Next
    For Each elem In Application.Sheets
        MsgBox "(insieme Sheets) elem.Name = " & elem.Name
    Next


End Sub



Sub provaRange()
    colora Range("A1"), 1
    colora Range("B17:B20"), 3
    colora Range("A3:F9"), 7
    colora Range("D:D"), 4
    colora Range("H:H,J:J"), 8
    colora Range("11:11,13:15"), 6
End Sub

Sub colora(cosa As Range, colore As Integer)
    cosa.Interior.ColorIndex = colore
    cosa.Value = colore
End Sub

Sub coloraOffset(originale As Range, OffsetX As Integer, OffsetY As Integer, colore As Integer)
    colora originale, colore
    colora originale.Offset(OffsetX, OffsetY), colore
End Sub

Sub provaOffset()
    coloraOffset Range("A1"), 2, 3, 7
    coloraOffset Range("C7"), -2, 3, 3
    coloraOffset Range("F18"), 2, -3, 4
    coloraOffset Range("K11"), -2, -3, 6
End Sub

Sub provaOffsetGruppi()
    coloraOffset Range("A1:B4"), 6, 1, 7
    coloraOffset Range("F16,G20"), -2, -4, 6
    coloraOffset Range("I:I"), 0, 2, 8
End Sub

Sub creaDocumentoWord()
    Dim wdApp As New Word.Application
    Dim wdDoc As Word.Document
    Dim wdTable As Word.Table
    Dim wdRow As Word.Row

    Dim cella As Excel.Range

    wdApp.Visible = True
    Set wdDoc = wdApp.Documents.Add(, , , True)
    Set wdTable = wdDoc.Tables.Add(wdDoc.Range(), 1, 2)
    wdTable.Rows.Item(1).Alignment = wdAlignRowCenter
    wdTable.Cell(1, 1).Range.Characters.Item(1) = "Cella"
    wdTable.Cell(1, 2).Range.Characters.Item(1) = "Valore"
    For Each cella In ActiveWorkbook.ActiveSheet.UsedRange
        Set wdRow = wdTable.Rows.Add()
        wdRow.Cells(1).Range.Characters.Item(1) = cella.Address
        wdRow.Cells(2).Range.Characters.Item(1) = cella.Characters.Text
    Next
    wdApp.Quit
    Set wdApp = Nothing
End Sub

Sub creaPresentazionePowerPoint()
    Dim app As New PowerPoint.Application
    Dim nuovaPresentazione As PowerPoint.Presentation
    Dim nuovaSlide As PowerPoint.Slide
    Dim indiceSlide As Integer
    indiceSlide = 1
    app.Visible = msoTrue
    Set nuovaPresentazione = app.Presentations.Add
    Set nuovaSlide = _
        nuovaPresentazione.Slides.Add(indiceSlide, ppLayoutText)
    nuovaSlide.Shapes.Item(1).TextFrame.TextRange.Text = "Titolo"
    nuovaSlide.Shapes.Item(2).TextFrame.TextRange.Text = "Testo inserito"
    indiceSlide = indiceSlide + 1
    Set nuovaSlide = _
        nuovaPresentazione.Slides.Add(indiceSlide, ppLayoutVerticalText)
    nuovaSlide.Shapes.Item(1).TextFrame.TextRange.Text = "Titolo"
    nuovaSlide.Shapes.Item(2).TextFrame.TextRange.Text = "Testo inserito"
    indiceSlide = indiceSlide + 1
    Set nuovaSlide = _
        nuovaPresentazione.Slides.Add(indiceSlide, ppLayoutOrgchart)
    indiceSlide = indiceSlide + 1
    Set nuovaSlide = _
        nuovaPresentazione.Slides.Add(indiceSlide, ppLayoutTextAndChart)
    indiceSlide = indiceSlide + 1
    Set nuovaSlide = _
        nuovaPresentazione.Slides.Add(indiceSlide, ppLayoutChartAndText)

    indiceSlide = indiceSlide + 1
    Set nuovaSlide = _
        nuovaPresentazione.Slides.Add(indiceSlide, ppLayoutClipartAndText)

    indiceSlide = indiceSlide + 1
    Set nuovaSlide = _
        nuovaPresentazione.Slides.Add(indiceSlide, ppLayoutMediaClipAndText)

End Sub


Sub creaEmailOutlook()
    Dim applic As Outlook.Application
    Dim messaggio As Outlook.MailItem
    Set applic = New Outlook.Application
    Set messaggio = applic.CreateItem(olMailItem)
    messaggio.Body = "Corpo"
    messaggio.Subject = "Soggetto"
    messaggio.Recipients.Add "[e-mail]"
    messaggio.CC = "[e-mail]"
    messaggio.Display
End Sub

Sub testaFS()
    testaFileSearch "Z:\Ivan"
End Sub

Sub testaFileSearch(path As String)
    Dim lista As String
    Dim i As Integer

    lista = ""
    With Application.FileSearch
        .NewSearch
        .Filename = "m*"
        .FileType = msoFileTypeOfficeFiles
        .LookIn = path
        .SearchSubFolders = True
        .Execute
        For i = 1 To .FoundFiles.Count
            lista = lista & VBA.vbCrLf & VBA.vbTab & .FoundFiles(i)
        Next i
    End With
    MsgBox "File che soddisfano i criteri di ricerca:" & lista
End Sub